Visual Basic Source Code/Visual Basic Source Code.iso/vbsource/vidlibp/vidcopy.frm

Visual Basic Form | 1995-05-07 | 14.5 KB | 479 lines

VERSION 2.00
Begin Form VidCopy
   BackColor       =   &H00C0C0C0&
   BorderStyle     =   1  'Fixed Single
   Caption         =   "Copy Video Data"
   ClientHeight    =   3195
   ClientLeft      =   2205
   ClientTop       =   1800
   ClientWidth     =   4755
   Height          =   3600
   HelpContextID   =   130
   Left            =   2145
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   3195
   ScaleWidth      =   4755
   Top             =   1455
   Width           =   4875
   Begin PictureBox dlgFromTo
      Height          =   480
      Left            =   0
      ScaleHeight     =   450
      ScaleWidth      =   1170
      TabIndex        =   10
      Top             =   0
      Width           =   1200
   End
   Begin CommandButton cmdTo
      Caption         =   "&To"
      Height          =   540
      HelpContextID   =   130
      Left            =   3240
      TabIndex        =   3
      Top             =   1125
      Width           =   1230
   End
   Begin CommandButton cmdFrom
      Caption         =   "&From"
      Height          =   540
      HelpContextID   =   130
      Left            =   3240
      TabIndex        =   2
      Top             =   150
      Width           =   1230
   End
   Begin CommandButton cmdDone
      Cancel          =   -1  'True
      Caption         =   "&Done"
      Height          =   540
      HelpContextID   =   130
      Left            =   3240
      TabIndex        =   4
      Top             =   2100
      Width           =   1230
   End
   Begin CommandButton cmdCopy
      Caption         =   "&Copy"
      Default         =   -1  'True
      Height          =   540
      HelpContextID   =   130
      Left            =   1755
      TabIndex        =   0
      Top             =   2100
      Width           =   1230
   End
   Begin CommandButton cmdOptions
      Caption         =   "&Options"
      Height          =   540
      HelpContextID   =   130
      Left            =   270
      TabIndex        =   1
      Top             =   2100
      Width           =   1230
   End
   Begin Label lblMessage
      BackColor       =   &H00FFFF00&
      BorderStyle     =   1  'Fixed Single
      Height          =   240
      Left            =   270
      TabIndex        =   9
      Top             =   2775
      Width           =   4200
   End
   Begin Label lblToPath
      BackColor       =   &H00FFFF00&
      BorderStyle     =   1  'Fixed Single
      Height          =   240
      Left            =   270
      TabIndex        =   8
      Top             =   1725
      Width           =   4200
   End
   Begin Label lblFromPath
      BackColor       =   &H00FFFF00&
      BorderStyle     =   1  'Fixed Single
      Height          =   240
      Left            =   270
      TabIndex        =   6
      Top             =   750
      Width           =   4200
   End
   Begin Label lblTo
      AutoSize        =   -1  'True
      BackColor       =   &H00C0C0C0&
      Caption         =   "To Path\Name:"
      Height          =   195
      Left            =   270
      TabIndex        =   7
      Top             =   1500
      Width           =   1320
   End
   Begin Label lblFrom
      AutoSize        =   -1  'True
      BackColor       =   &H00C0C0C0&
      Caption         =   "From Path\Name:"
      Height          =   195
      Left            =   270
      TabIndex        =   5
      Top             =   525
      Width           =   1500
   End
' Subsystem: Copy
' Module:    VidCopy.Frm
' Date:      01/01/94
' Author:    Richard Stauch
' Notes:
' This form allows the user to copy one or more database table
' to another. If the file doesn't exist in the "Copy To" string,
' it is automatically created. Only whole tables can be copied;
' the user cannot select a subset of data.
Option Explicit
DefInt A-Z
' Constants
Const FROM_DIRECTION = 1 ' Flags for path setting functions.
Const TO_DIRECTION = 2
Const GENRE_DATA = 1  ' Flags to set tables-to-copy.
Const RATING_DATA = 2
Const VIDEO_DATA = 3
' Module-Level Variables
Dim FromDOSPath As String ' Path string to copy from.
Dim ToDOSPath As String   ' Path string to copy to.
Sub ClearData (RecordInt As Integer)
' The user wants to Replace, so clear the table.
Dim DB As Database ' Reference the database object.
Dim T As Table     ' Reference the table object.
' If there is no database, create it.
  On Error GoTo NoClearDB
' Set the database object (Exclusive = True, Read-Only = False).
  Set DB = OpenDatabase(CopyName$, True, False)
' If there is a problem after this, just exit.
  On Error GoTo ClearError
' Open the table to clear.
  Select Case RecordInt%
    Case GENRE_DATA
      Set T = DB.OpenTable("Genre")
    Case RATING_DATA
      Set T = DB.OpenTable("Rating")
    Case VIDEO_DATA
      Set T = DB.OpenTable("Video")
  End Select ' RecordInt%
  Do While Not T.EOF
  ' Delete all records.
    T.Delete
  ' Make sure Windows has an opportunity to update itself.
    DoEvents
  Loop
' The table is empty now, so close it and exit.
  T.Close
  DB.Close
  Exit Sub
NoClearDB:
  If CheckFile(CopyName$) Then
  ' If the file exists there's some problem with it.
    GenericMsgBox (MBC_BADFILE)
    Exit Sub
  Else
  ' If it doesn't exist, create it.
    If CreateDataFile(CopyName$) Then
    ' We've created the file, so continue.
      Resume 0
    Else
    ' We had some problem creating the file.
      Exit Sub
    End If
  End If
ClearError:
' There is some problem with the database file.
  GenericMsgBox (MBC_BADFILE)
  Exit Sub
End Sub
Sub cmdCopy_Click ()
' Perform the copy operation according to the options set.
Dim T As String ' Temp to hold current message string.
  T$ = lblMessage.Caption
  lblMessage.Caption = "Copying data."
  If Not (GenreCopy% Or RatingCopy% Or VideoCopy%) Then
  ' The user must indicate some table to copy.
    GenericMsgBox (MBC_NOTABLES)
    lblMessage.Caption = T$
    Exit Sub
  End If
  If PathName$ = CopyName$ Then
  ' You cannot copy a file onto itself.
    GenericMsgBox (MBC_COPYPROBLEM)
    lblMessage.Caption = T$
    Exit Sub
  End If
  If ReplaceData% = True Then
  ' Replace option = True; ask user if they're sure.
    If GenericCancelBox(MBC_REPLACEDATA) = True Then
    ' User pressed the Cancel button.
      lblMessage.Caption = T$
      Exit Sub
    End If
  End If
' Indicate "Wait".
  Screen.MousePointer = HOURGLASS
' Go [Clear]/Append data.
  CopyControl
' Indicate "Continue".
  Screen.MousePointer = DEFAULT
' Display original message text.
  lblMessage.Caption = T$
End Sub
Sub cmdDone_Click ()
' Remove the Copy form from the screen.
  Unload VidCopy
End Sub
Sub cmdFrom_Click ()
' Set the "From" file name.
Dim T As String ' Save the original message.
Dim X As String ' Check for null return string.
  T$ = lblMessage.Caption
  lblMessage.Caption = "Setting 'From' path\name."
' Get the path and file name.
  X$ = SetPath(FROM_DIRECTION)
  If Len(X$) = 0 Then ' Check for empty string!
    lblMessage.Caption = T$
    Exit Sub
  End If
' Show the selected fully qualified file name.
  lblFromPath.Caption = X$
  PathName$ = X$
' Get the path portion of the file name.
  X$ = SeperatePath(PathName$)
  If Len(X$) = 0 Then ' Check for empty string!
    lblMessage.Caption = T$
    Exit Sub
  End If
' Show the path name.
  FromDOSPath$ = X$
  lblMessage.Caption = T$
End Sub
Sub cmdOptions_Click ()
' Let the user select file copy options.
Dim T As String ' Save original message text.
  T$ = lblMessage.Caption
' Inform the user what we're doing.
  lblMessage.Caption = "Set copy options."
' Display the Copy Options form.
  VidOpt.Show MODAL
' Restore the original message text.
  lblMessage.Caption = T$
End Sub
Sub cmdTo_Click ()
' Set the "To" file name.
Dim T As String ' Save the original message.
Dim X As String ' Check for null return string.
  T$ = lblMessage.Caption
  lblMessage.Caption = "Setting 'To' path\name."
' Get the path and file name.
  X$ = SetPath(TO_DIRECTION)
  If Len(X$) = 0 Then ' Check for empty string!
    lblMessage.Caption = T$
    Exit Sub
  End If
' Show the selected fully qualified file name.
  lblToPath.Caption = X$
  CopyName$ = X$
' Get the path portion of the file name.
  X$ = SeperatePath(CopyName$)
  If Len(X$) = 0 Then ' Check for empty string!
    lblMessage.Caption = T$
    Exit Sub
  End If
' Show the path name.
  ToDOSPath$ = X$
  lblMessage.Caption = T$
End Sub
Sub CopyControl ()
' Control Replace and Copy functions.
  If GenreCopy% = True Then
  ' Copy the Genre table.
    If ReplaceData% = True Then
    ' Clear it first.
      ClearData (GENRE_DATA)
    End If
    CopyData (GENRE_DATA)
  End If
  If RatingCopy% = True Then
  ' Copy the Rating table.
    If ReplaceData% = True Then
    ' Clear it first.
      ClearData (RATING_DATA)
    End If
    CopyData (RATING_DATA)
  End If
  If VideoCopy% = True Then
  ' Copy the Video table.
    If ReplaceData% = True Then
    ' Clear it first.
      ClearData (VIDEO_DATA)
    End If
    CopyData (VIDEO_DATA)
  End If
End Sub
Sub CopyData (RecordInt As Integer)
' Copy the selected table.
Dim DB1 As Database   ' Reference the "From" database object.
Dim T1 As Table       ' Reference the "From" table object.
Dim DB2 As Database   ' Reference the "To" database object.
Dim T2 As Table       ' Reference the "To" table object.
Dim FCount As Integer ' Number of fields in the table.
Dim I As Integer      ' Fields counter/pointer.
' If there is no database, create it.
  On Error GoTo NoCopyDB
' Set the "To" database object (Exclusive = True, Read-Only = False).
  Set DB2 = OpenDatabase(CopyName$, True, False)
' If there is a problem after this, just exit.
  On Error GoTo CopyError
' Set the "From" database object (Exclusive = False, Read-Only = True).
  Set DB1 = OpenDatabase(PathName$, False, True)
' Open the tables to copy "From" and "To".
  Select Case RecordInt%
    Case GENRE_DATA
    ' Copy the Genre table.
      Set T1 = DB1.OpenTable("Genre")
      Set T2 = DB2.OpenTable("Genre")
    Case RATING_DATA
    ' Copy the Rating table.
      Set T1 = DB1.OpenTable("Rating")
      Set T2 = DB2.OpenTable("Rating")
    Case VIDEO_DATA
    ' Copy the Video table.
      Set T1 = DB1.OpenTable("Video")
      Set T2 = DB2.OpenTable("Video")
  End Select ' RecordInt%
' Find the count of fields in this table.
  FCount% = T1.Fields.Count
  Do While Not T1.EOF
  ' Add a new record and copy each field.
    T2.AddNew
    For I% = 0 To FCount% - 1
    ' Table "Fields" index starts at zero.
      T2(I%) = T1(I%)
    Next I%
  ' Update the new "To" record, and move to the next "From" record.
    T2.Update
    T1.MoveNext
  ' Make sure Windows has an opportunity to update itself.
    DoEvents
  Loop ' Not T1.EOF
' We're finished copying, so close the files and exit.
  T1.Close : DB1.Close ' Close the "From" file.
  T2.Close : DB2.Close ' Close the "To" file.
  Exit Sub
NoCopyDB:
  If CheckFile(CopyName$) Then
  ' If the file exists there's some problem with it.
    GenericMsgBox (MBC_BADFILE)
    Exit Sub
  Else
  ' If it doesn't exist, create it.
    If CreateDataFile(CopyName$) Then
      Resume 0
    Else
      Exit Sub
    End If
  End If
CopyError:
' There is some problem with the database file.
  GenericMsgBox (MBC_BADFILE)
  Exit Sub
End Sub
Sub Form_Load ()
' Load the Copy form.
Dim X As String ' Check for null return string.
' Inform the user what we're doing.
  lblMessage.Caption = "Select 'From' and 'To' path\file names."
  lblFromPath.Caption = PathName$
  lblToPath.Caption = CopyName$
' Set the 'From' and 'To' DOS path names.
  X$ = SeperatePath(PathName$)
  FromDOSPath$ = X$
  X$ = SeperatePath(CopyName$)
  ToDOSPath$ = X$
' Set the Help file name for the dialog box.
  dlgFromTo.HelpFile = HelpName$
End Sub
Sub lblFrom_Click ()
' Call the Click event of the associated command button.
  cmdFrom_Click
End Sub
Sub lblFromPath_Click ()
' Call the Click event of the associated command button.
  cmdFrom_Click
End Sub
Sub lblTo_Click ()
' Call the Click event of the associated command button.
  cmdTo_Click
End Sub
Sub lblToPath_Click ()
' Call the Click event of the associated command button.
  cmdTo_Click
End Sub
Function SeperatePath (FileStr As String) As String
' Find the "Path" portion of a fully qualified file name.
Dim I As Integer ' Counter; pointer to the last "\" in the string.
  If Len(FileStr$) = 0 Then
  ' The FileStr$ variable is empty.
    GenericMsgBox (MBC_BADFILE)
  ' Calling procedures must check for empty string.
    SeperatePath$ = ""
    Exit Function
  End If
  For I% = Len(FileStr$) To 1 Step -1
  ' Find the last "\" in the string.
    If Mid$(FileStr$, I%, 1) = "\" Then Exit For
  Next I%
  If I% > 3 Then
  ' This is a subdirectory, not a root directory.
    I% = I% - 1 ' Remove the trialing "\".
  ElseIf I% < 3 Then
  ' There is no "\" in the FileStr$ variable.
    GenericMsgBox (MBC_BADFILE)
  ' Calling procedures must check for empty string.
    SeperatePath$ = ""
  End If
' The result is a useable "Drive:\[Path]" string.
  SeperatePath$ = Left$(FileStr$, I%)
End Function
Function SetPath (Direction As Integer) As String
' Use the common dialog control to set a fully qualified file name.
  Select Case Direction
  ' Set up the dialog box.
    Case FROM_DIRECTION
    ' Indicate the "From" direction.
      dlgFromTo.DialogTitle = "Select 'From' Path\Name"
      dlgFromTo.Filename = PathName$
      dlgFromTo.InitDir = FromDOSPath$
      dlgFromTo.Flags = OFN_FILEMUSTEXIST Or OFN_SHOWHELP
    Case TO_DIRECTION
    ' Indicate the "To" direction.
      dlgFromTo.DialogTitle = "Select 'To' Path\Name"
      dlgFromTo.Filename = CopyName$
      dlgFromTo.InitDir = ToDOSPath$
      dlgFromTo.Flags = OFN_CREATEPROMPT Or OFN_SHOWHELP
  End Select
' Check for Open dialog Cancel button (CancelError property = True).
  On Error GoTo SetCancel
  dlgFromTo.Action = DLG_FILE_OPEN
' Deactivate the error handler.
  On Error GoTo 0
' Set the result from the dialog box and exit.
  If dlgFromTo.Flags And OFN_EXTENSIONDIFFERENT Then
  ' Calling procedure must check for empty string.
    GenericMsgBox (MBC_BADFILE)
    SetPath$ = ""
  Else
    SetPath$ = dlgFromTo.Filename
  End If
  Exit Function
SetCancel:
' User pressed the cancel button.
  SetPath$ = ""
  Exit Function
End Function